home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Taifun
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf
/
PCQ
/
Source
/
IO.p
< prev
next >
Wrap
Text File
|
1989-03-31
|
17KB
|
799 lines
external;
{
IO.p (of PCQ Pascal)
Copyright (c) 1989 Patrick Quaid
This module handles the IO of the compiler. The actual
compilation of the io statements is handled in stanprocs.p
}
const
{$I "pasconst.i"}
type
{$I "pastype.i"}
var
{$I "pasvar.i"}
procedure doinclude;
forward;
function AllocString(i : integer): string;
forward;
procedure FreeString(s : string);
forward;
function searchreserved(): integer;
forward;
function raise(c : Char): Char;
forward;
procedure readchar;
forward;
procedure endinclude;
forward;
{ This routine lists the contents of the identifier table for
debugging purposes.
procedure dumptypes;
var
index : integer;
begin
for index := 1 to identptr - 1 do begin
write(index, chr(9));
if idents[index].name = string(adr(spelling)) then
writeln('no name')
else
writeln(idents[index].name);
writeln('object ', idents[index].object);
writeln('offset ', idents[index].offset);
writeln('vtype ', idents[index].vtype);
writeln('upper ', idents[index].upper);
writeln('lower ', idents[index].lower);
writeln('size ', idents[index].size);
writeln('indtype ', idents[index].indtype);
writeln;
end;
end;
}
procedure abort;
{
This routine cuts out cleanly. If you are debugging the
compiler, this is a likely place to put post mortem dumps, like the
one commented out.
}
begin
if including then begin
close(input2);
close(input);
end else
close(input);
writeln('Compilation aborted');
{ writeln('IdentPtr = ', identptr, '. SpellPtr = ', spellptr,
'. LitPtr = ', litptr);
dumptypes; }
exit(20);
end;
function eqfix(x : integer): integer;
{
This helps implement a queue. In this case it's for the
error queue.
}
begin
if x = -1 then
eqfix := eqsize
else
eqfix := x mod (eqsize + 1);
end;
procedure error(ptr : string);
{
This just writes out at most the previous 128 characters or
two lines, then writes the error message passed to it. If there
are more than five errors, it aborts.
}
var
index : integer;
newlines : integer;
begin
index := eqend;
newlines := 0;
while (index <> eqstart) and (newlines < 2) do begin
index := eqfix(index - 1);
if errorq[eqfix(index - 1)] = chr(10) then
newlines := newlines + 1;
end;
while index <> eqend do begin
if index = errorptr then
write(chr($9b), '0;33;40m'); { start highlight for ANSI }
write(errorq[index]);
index := eqfix(index + 1);
end;
write(chr($9b), '0;31;40m'); { end highlight }
writeln;
if including then
write('"', includename, '", ')
else
write('"', mainname, '", ');
write('Line ', lineno, ' ');
if currfn <> 0 then
write('(', idents[currfn].name, ')');
writeln(': ', ptr);
writeln;
{ writeln('Identptr = ', identptr, '. SpellPtr = ', spellptr); }
errorcount := errorcount + 1;
if errorcount > 5 then
abort;
end;
function endoffile(): boolean;
{
This is the modified eof() function. This is necessary
because of include files.
}
begin
if including then
if eof(input2) then begin
endinclude;
endoffile := eof(input);
end else
endoffile := false;
else
endoffile := eof(input);
end;
procedure endcomment;
{
This just eats characters up to the end of a comment. If
you want nested comments, this is probably the place to do it.
}
begin
while currentchar <> '}' do begin
if endoffile() then begin
error("The file ended in a comment!");
return;
end;
readchar;
end;
readchar;
end;
procedure endinclude;
{
This switches the input back to the main file.
}
begin
close(input2);
including := false;
lineno := saveline;
fnstart := savestart;
currentchar := savechar;
endcomment;
end;
procedure readchar;
{
This just reads a character from wherever it's appropriate.
In the next version, the options might include an ARexx port.
}
begin
if including then begin
if eof(input2) then begin
endinclude;
end else
read(input2, currentchar)
end else
read(input, currentchar);
{ At this point the character is read. The following code just
inserts the character into a queue, which will be printed if
we hit an error. }
if currentchar = chr(10) then
lineno := lineno + 1;
eqend := eqfix(eqend + 1);
errorq[eqend] := currentchar;
if eqstart = eqend then
eqstart := eqfix(eqend + 1);
end;
procedure gch;
{
This reads a character from the same line, for situations
where a symbol cannot be spread over two lines.
}
begin
if currentchar <> chr(10) then
readchar;
end;
function getlabel() : integer;
{
As in all compilers, this just returns a unique serial
number.
}
begin
nxtlab := nxtlab + 1;
getlabel := nxtlab;
end;
procedure printlabel(lab : integer);
{
This routine prints a label based on a number from the
above procedure. The prefix for the label can be anything the
assembler accepts - in this case I wanted it similar to the prefix
of the run time library routines. I didn't realize how ugly it
would look.
}
begin
write(output, '_p%', lab);
end;
function nch(): char;
{
This stands for next character, and just returns the
buffered character from the appropriate file. It looks ahead.
}
begin
if including then
nch := input2^
else
nch := input^;
end;
procedure doinclude;
{
The name says it all. The mechanics of the include
directive are all handled here. If you want to nest includes,
you'll have to implement a list or something here, then adjust
endoffile(), readchar(), nextchar(), etc. Not too hard, I suppose.
}
var
c : string;
begin
if including then
error("Cannot nest include files")
else begin
while (currentchar = ' ') or (currentchar = chr(9)) or
(currentchar = chr(10)) do
readchar;
if currentchar = '"' then
gch
else
error("missing open quote");
c := includename;
while (currentchar <> '"') and (currentchar <> chr(10)) do begin
c^ := currentchar;
readchar;
c := string(integer(c) + 1); { sorry. }
end;
if currentchar = '"' then
readchar
else
error("missing close quote");
c^ := chr(0);
if reopen(includename, input2) then begin
saveline := lineno;
savestart := fnstart;
savechar := currentchar;
including := true;
readchar;
end else
error("Could not open include file");
end
end;
procedure docomment;
{
This routine implements compiler directives. When I get a
few more directives I'll probably split these up a bit. I'd also
like to make the directives themselves full words.
}
begin
readchar;
if currentchar = '$' then begin
readchar;
if currentchar = 'I' then begin
readchar;
doinclude;
return;
end else if currentchar = 'A' then begin
readchar;
while currentchar <> '}' do begin
write(output, currentchar);
if endoffile() then begin
error("File ended in a comment");
return;
end;
readchar;
end;
readchar;
writeln(output);
return;
end else if currentchar = 'R' then begin
readchar;
if currentchar = '+' then
rangecheck := true
else if currentchar = '-' then
rangecheck := false;
end;
end;
endcomment;
end;
function alpha(c : char): boolean;
{
This function answers the eternal question "is this
character an alphabetic character?" Note that _ is.
}
begin
if (ord(c) >= ord('a')) and (ord(c) <= ord('z')) then
alpha := true
else if (ord(c) >= ord('A')) and (ord(c) <= ord('Z')) then
alpha := true
else if c = '_' then
alpha := true
else
alpha := false;
end;
function numeric(c : char): boolean;
{
Is the character a digit?
}
begin
numeric := (ord(c) >= ord('0')) and (ord(c) <= ord('9'));
end;
function an(c : char): boolean;
{
Is the character a letter or digit?
}
begin
an := alpha(c) or numeric(c);
end;
procedure header;
{
This routine references all the run time library routines.
One thing I like about A68k is that the only routines that will
actually be referenced are those that are used in the code. Maybe
all assemblers do this, but I don't know.
}
begin
writeln(output, "* Pascal compiler intermediate assembly program.\n\n");
writeln(output, "\tSECTION\tONE\n");
writeln(output, "\tXREF\t_stdout");
writeln(output, "\tXREF\t_p%writeint");
writeln(output, "\tXREF\t_p%writechar");
writeln(output, "\tXREF\t_p%writebool");
writeln(output, "\tXREF\t_p%writecharray");
writeln(output, "\tXREF\t_p%writestring");
writeln(output, "\tXREF\t_p%writeln");
writeln(output, "\tXREF\t_p%readint");
writeln(output, "\tXREF\t_p%readcharray");
writeln(output, "\tXREF\t_p%readchar");
writeln(output, "\tXREF\t_p%readarbbuf");
writeln(output, "\tXREF\t_p%readstring");
writeln(output, "\tXREF\t_p%readln");
writeln(output, "\tXREF\t_p%readarb");
writeln(output, "\tXREF\t_p%dispose");
writeln(output, "\tXREF\t_p%new");
writeln(output, "\tXREF\t_p%open");
writeln(output, "\tXREF\t_p%writearb");
writeln(output, "\tXREF\t_p%close");
writeln(output, "\tXREF\t_p%case");
writeln(output, "\tXREF\t_p%exit\n");
if mainmode then begin
writeln(output, "\tXREF\t_p%initialize");
writeln(output, "\tXREF\t_p%wrapitup");
writeln(output, "\tjsr\t_p%initialize");
writeln(output, "\tjsr\t_MAIN");
writeln(output, "\tjsr\t_p%wrapitup");
writeln(output, "\trts");
end
end;
procedure trailer;
{
This routine is the most important in the compiler
}
begin
writeln(output, "\tEND");
end;
procedure blanks;
{
blanks() skips spaces, tabs and eoln's. It handles
comments if it comes across one.
}
var
done : boolean;
begin
if currentchar = '{' then
docomment;
done := false;
while not done do begin
if endoffile() then
done := true
else if (currentchar = ' ') or (currentchar = chr(9)) or
(currentchar = chr(10)) then
readchar
else if currentchar = '{' then
docomment;
else
done := true;
end;
end;
procedure dumplits;
{
This procedure dumps the literal table at the end of the
compilation. Individual components are referenced as offsets to
the literal label.
}
var
j, k : integer;
quotemode : boolean;
begin
if litptr = 0 then
return;
writeln(output, "\n\tSECTION\tTWO,DATA\n");
printlabel(litlab);
k := 1;
while k < litptr do begin
write(output, "\tdc.b\t");
j := 0;
quotemode := false;
while j < 40 do begin
if (ord(litq[k]) > 31) and (ord(litq[k]) <> 39) then begin
if quotemode then
write(output, litq[k])
else begin
if j > 0 then
write(output, ',');
write(output, chr(39), litq[k]);
quotemode := true;
end;
end else begin
if quotemode then begin
write(output, chr(39));
quotemode := false;
end;
if j > 0 then
write(output, ',');
write(output, ord(litq[k]));
if j > 32 then
j := 40
else
j := j + 3;
end;
j := j + 1;
k := k + 1;
if k >= litptr then
j := 40;
end;
if quotemode then
write(output, chr(39));
writeln(output);
end
end;
procedure dumpids;
{
This routine does whatever is appropriate with the various
identifers. If it's a global, it either references it or allocates
space. Similar stuff for the other ids. When the modularity of
PCQ is better defined, this routine will have to do more work.
}
var
vartype : integer;
index : integer;
isodd : boolean;
begin
if mainmode then
writeln(output, "\n\tSECTION\tTHREE,BSS\n");
index:= 1;
isodd := false;
while index < identptr do begin
if idents[index].object = global then begin
if mainmode then begin
vartype := idents[index].vtype;
if isodd and (idents[vartype].size > 1) then begin
writeln(output, "\tCNOP\t0,2");
isodd := false;
end;
writeln(output, "\tXDEF\t_", idents[index].name);
write(output, '_', idents[index].name);
writeln(output, "\tds.b\t", idents[vartype].size);
if odd(idents[vartype].size) then
isodd := not isodd;
end else
writeln(output, "\tXREF\t_", idents[index].name);
end else if (idents[index].object = proc) or
(idents[index].object = func) then
if idents[index].upper = 0 then
writeln(output, "\tXREF\t_", idents[index].name);
index := index + 1;
end
end;
procedure readword;
{
This reads a Pascal identifier into symtext.
}
var
index : integer;
ptr : string;
begin
index := 0;
ptr := symtext;
while an(currentchar) do begin
ptr^ := currentchar;
gch;
ptr := string(integer(ptr) + 1); { here's that thing again...}
end;
ptr^ := chr(0);
currsym := searchreserved();
if currsym = 0 then
currsym := ident1;
symloc := 0;
end;
procedure readnumber;
{
This routine reads a literal integer. Since it uses *, it
will not properly handle numbers whose magnitude is greater than
about 200,000 or 300,000. Note that _ can be used.
}
var
negative : boolean;
begin
if currentchar = '-' then begin
negative := true;
gch();
end else
negative := false;
symloc:= 0;
while numeric(currentchar) do begin
symloc := symloc * 10 + ord(currentchar) - ord('0');
gch();
if currentchar = '_' then
gch();
end;
if negative then
symloc := -symloc;
currsym := numeral1;
end;
procedure readhex;
{
readhex() reads a hexadecimal number. Since it uses the
assembly instructions it is able to read full 32 bit values.
}
var
rc : integer;
begin
gch;
symloc := 0;
rc := ord(raise(currentchar));
while numeric(currentchar) or
((rc >= ord('A')) and (rc <= ord('F'))) do begin
{$A move.l _symloc,d0
asl.l #4,d0
move.l d0,_symloc ; symloc := symloc * 16;
}
if numeric(currentchar) then
symloc := symloc + ord(currentchar) - ord('0')
else
symloc := symloc + rc - ord('A') + 10;
gch;
rc := ord(raise(currentchar));
end;
currsym := numeral1;
end;
procedure writehex(num : integer);
{
This writes full 32 bit hexadecimal numbers.
}
var
numary : array [1..8] of char;
pos : integer;
ch : char;
begin
pos := 8;
while (num <> 0) and (pos > 0) do begin
{$A move.l 8(a5),d0
and.b #15,d0
move.b d0,-13(a5) ; ch := num AND $0f;
}
if ord(ch) < 10 then
numary[pos] := chr(ord(ch) + ord('0'))
else
numary[pos] := chr(ord(ch) + ord('A') - 10);
pos := pos - 1;
{$A move.l 8(a5),d0
lsr.l #4,d0
move.l d0,8(a5) ; num := num div 16;
}
end;
if pos = 8 then begin
pos := 7;
numary[8] := '0';
end;
write(output, '$');
for num := pos + 1 to 8 do
write(output, numary[num]);
end;
procedure nextsymbol;
{
This is the workhorse lexical analysis routine. It sets
currsym to the appropriate symbol number, sets symtext equal to
whatever identifier is read, and symloc to the value of a literal
integer.
Soon this will be a big case statement.
}
begin
errorptr := eqend;
blanks;
if endoffile() then begin
currentchar := chr(0);
currsym := endtext1; { I don't think this routine is ever hit }
return;
end;
while currentchar = '{' do begin
docomment; { I think this is unused }
blanks;
end;
if alpha(currentchar) then
readword
else if numeric(currentchar) then
readnumber
else if currentchar = '[' then begin
currsym:= leftbrack1;
readchar;
end else if currentchar = ']' then begin
currsym:= rightbrack1;
readchar;
end else if currentchar = '(' then begin
currsym:= leftparent1;
readchar;
end else if currentchar = ')' then begin
currsym:= rightparent1;
readchar;
end else if currentchar = '+' then begin
currsym := plus1;
readchar;
end else if currentchar = '-' then begin
currsym := minus1;
readchar;
end else if currentchar = '*' then begin
currsym:= asterisk1;
readchar;
end else if currentchar = '<' then begin
gch;
if currentchar = '=' then begin
currsym := notgreater1;
readchar;
end else if currentchar = '>' then begin
currsym := notequal1;
readchar;
end else
currsym:= less1;
end else if currentchar = '=' then begin
currsym:= equal1;
readchar;
end else if currentchar = '>' then begin
gch;
if currentchar = '=' then begin
currsym:= notless1;
readchar;
end else
currsym:= greater1;
end else if currentchar = ':' then begin
gch;
if currentchar = '=' then begin
currsym:= becomes1;
readchar;
end else
currsym:= colon1;
end else if currentchar = ',' then begin
currsym:= comma1;
readchar;
end else if currentchar = '.' then begin
gch;
if currentchar = '.' then begin
currsym:= dotdot1;
readchar;
end else
currsym:= period1;
end else if currentchar = ';' then begin
currsym:= semicolon1;
readchar;
end else if currentchar = chr(39) then begin
currsym:= apostrophe1;
readchar;
end else if currentchar = '"' then begin
currsym:= quote1;
readchar;
end else if currentchar = '^' then begin
currsym:= carat1;
readchar;
end else if currentchar = '$' then
readhex;
else if currentchar = chr(0) then
currsym:= endtext1;
else begin
error("Unknown symbol.");
readchar;
end
end;